home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / program / blx13.zip / PASENG.ZIP / PXACCESS.PAS next >
Pascal/Delphi Source File  |  1991-03-11  |  9KB  |  371 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Paradox Engine demo access unit              }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit PXAccess;
  10.  
  11. interface
  12.  
  13. {$N+}
  14.  
  15. uses WObjects, PXEngine;
  16.  
  17. type
  18.   PFieldArray = ^TFieldArray;
  19.   TFieldArray = array[1..256] of PChar;
  20.  
  21. type
  22.   PPXTable = ^TPXTable;
  23.   TPXTable = object(TObject)
  24.     Status: Integer;
  25.     constructor Init(TableName: PChar);
  26.     destructor Done; virtual;
  27.     procedure ClearError;
  28.     function FieldName(Field: Integer): PChar;
  29.     function FieldType(Field: Integer): PChar;
  30.     function FieldWidth(Field: Integer): Integer;
  31.     function Find(Value: PChar): RecordNumber;
  32.     function FindNext: RecordNumber;
  33.     function GetField(Rec, Fld: Integer): PChar;
  34.     function NumRecords: LongInt;
  35.     function NumFields: Integer;
  36.     procedure PXError(Error: Integer); virtual;
  37.     function Update: Boolean;
  38.   private
  39.     CurRecord: Integer;
  40.     TblHandle: TableHandle;
  41.     RecHandle: RecordHandle;
  42.     NumFlds: Integer;
  43.     NumRecs: LongInt;
  44.     FieldNames: PFieldArray;
  45.     FieldTypes: PFieldArray;
  46.     Cache: Pointer;
  47.     TableTime: LongInt;
  48.     function CheckError(Code: Integer): Boolean;
  49.     procedure CacheTable;
  50.     procedure FlushTable;
  51.     function TblName: PChar;
  52.   end;
  53.  
  54. implementation
  55.  
  56. uses WinTypes, WinProcs, Strings, WinDos;
  57.  
  58. type
  59.   PCache = ^TCache;
  60.   TCache = object(TCollection)
  61.     constructor Init(CacheSize: Integer);
  62.     procedure Add(Index: LongInt; P: PChar);
  63.     function Get(Index: LongInt): PChar;
  64.     procedure FreeItem(P: Pointer); virtual;
  65.   end;
  66.  
  67. type
  68.   PCacheElement = ^TCacheElement;
  69.   TCacheElement = record
  70.     Index: LongInt;
  71.     Item: PChar;
  72.   end;
  73.  
  74. constructor TCache.Init(CacheSize: Integer);
  75. begin
  76.   TCollection.Init(CacheSize, 0);
  77. end;
  78.  
  79. procedure TCache.Add(Index: LongInt; P: PChar);
  80. var
  81.   CE: PCacheElement;
  82. begin
  83.   New(CE);
  84.   CE^.Index := Index;
  85.   CE^.Item := P;
  86.   if Count = Limit then AtFree(Count - 1);
  87.   AtInsert(0, CE);
  88. end;
  89.  
  90. function TCache.Get(Index: LongInt): PChar;
  91. var
  92.   P: PCacheElement;
  93.  
  94.   function ItemWithIndex(P: PCacheElement): Boolean; far;
  95.   begin
  96.     ItemWithIndex := P^.Index = Index;
  97.   end;
  98.  
  99. begin
  100.   Get := nil;
  101.   P := FirstThat(@ItemWithIndex);
  102.   if P <> nil then Get := P^.Item;
  103. end;
  104.  
  105. procedure TCache.FreeItem(P: Pointer);
  106. begin
  107.   StrDispose(PCacheElement(P)^.Item);
  108.   Dispose(P);
  109. end;
  110.  
  111. { TPXTable }
  112.  
  113. function FileTime(F: PChar): LongInt;
  114. var
  115.   S: TSearchRec;
  116. begin
  117.   FindFirst(F, 0, S);
  118.   FileTime := S.Time;
  119. end;
  120.  
  121. constructor TPXTable.Init(TableName: PChar);
  122. begin
  123.   FieldTypes := nil;
  124.   FieldNames := nil;
  125.   Status := 0;
  126.   CurRecord := -1;
  127.   if CheckError(PXTblOpen(TableName, TblHandle, 0, False)) and
  128.      CheckError(PXRecBufOpen(TblHandle, RecHandle)) then
  129.     CacheTable;
  130. end;
  131.  
  132. destructor TPXTable.Done;
  133. begin
  134.   TObject.Done;
  135.   PXRecBufClose(RecHandle);
  136.   PXTblClose(TblHandle);
  137.   FlushTable;
  138. end;
  139.  
  140. procedure TPXTable.CacheTable;
  141. var
  142.   Temp: array[0..25] of Char;
  143.   I: Integer;
  144. begin
  145.   PXNetTblRefresh(TblHandle);
  146.   if CheckError(PXRecNFlds(TblHandle, NumFlds)) and
  147.      CheckError(PXTblNRecs(TblHandle, NumRecs)) then
  148.   begin
  149.     GetMem(FieldTypes, NumFields * SizeOf(PChar));
  150.     GetMem(FieldNames, NumFields * SizeOf(PChar));
  151.     for I := 1 to NumFields do
  152.     begin
  153.       CheckError(PXFldName(TblHandle, I, SizeOf(Temp), Temp));
  154.       FieldNames^[I] := StrNew(Temp);
  155.       CheckError(PXFldType(TblHandle, I, SizeOf(Temp), Temp));
  156.       FieldTypes^[I] := StrNew(Temp);
  157.     end;
  158.     Cache := New(PCache, Init(300));
  159.     TableTime := FileTime(TblName);
  160.   end;
  161. end;
  162.  
  163. function TPXTable.CheckError(Code: Integer): Boolean;
  164. begin
  165.   if Status = 0 then
  166.   begin
  167.     case Code of
  168.       { ignore the following errors }
  169. {      PXErr_RecDeleted,}
  170.       PXSuccess:
  171.     begin
  172.     end;
  173.     else
  174.       PXError(Code);
  175.       Status := Code;
  176.     end;
  177.   end;
  178.   CheckError := Status = 0;
  179. end;
  180.  
  181. procedure TPXTable.ClearError;
  182. begin
  183.   Status := 0;
  184. end;
  185.  
  186. function TPXTable.FieldName(Field: Integer): PChar;
  187. begin
  188.   if FieldNames <> nil then FieldName := FieldNames^[Field]
  189.   else FieldName := nil;
  190. end;
  191.  
  192. function TPXTable.FieldType(Field: Integer): PChar;
  193. begin
  194.   if FieldTypes <> nil then FieldType := FieldTypes^[Field]
  195.   else FieldType := nil;
  196. end;
  197.  
  198. function TPXTable.FieldWidth(Field: Integer): Integer;
  199. var
  200.   Width, Code: Integer;
  201. begin
  202.   FieldWidth := 0;
  203.   if FieldTypes <> nil then
  204.     case FieldTypes^[Field][0] of
  205.       'N',
  206.       '$': FieldWidth := 14;
  207.       'A':
  208.     begin
  209.       Val(PChar(@FieldTypes^[Field][1]), Width, Code);
  210.       FieldWidth := Width
  211.     end;
  212.       'D': FieldWidth := 12;
  213.       'S': FieldWidth := 8;
  214.     end;
  215. end;
  216.  
  217. function TPXTable.Find(Value: PChar): RecordNumber;
  218. var
  219.   RecNum: RecordNumber;
  220. begin
  221.   Find := 0;
  222.   CurRecord := -1;
  223.   if Status = 0 then
  224.     if CheckError(PXPutAlpha(RecHandle, 1, Value)) then
  225.       if PXSrchFld(TblHandle, RecHandle, 1, SearchFirst) = 0 then
  226.     if CheckError(PXRecNum(TblHandle, RecNum)) then
  227.       Find := RecNum;
  228. end;
  229.  
  230. function TPXTable.FindNext: RecordNumber;
  231. var
  232.   RecNum: RecordNumber;
  233. begin
  234.   FindNext := 0;
  235.   CurRecord := -1;
  236.   if Status = 0 then
  237.     if PXSrchFld(TblHandle, RecHandle, 1, SearchNext) = 0 then
  238.       if CheckError(PXRecNum(TblHandle, RecNum)) then
  239.     FindNext := RecNum;
  240. end;
  241.  
  242. procedure TPXTable.FlushTable;
  243. var
  244.   I: Integer;
  245. begin
  246.   if (FieldTypes <> nil) and (FieldNames <> nil) then
  247.   begin
  248.     for I := 1 to NumFields do
  249.     begin
  250.       StrDispose(FieldNames^[I]);
  251.       StrDispose(FieldTypes^[I]);
  252.     end;
  253.     FreeMem(FieldTypes, NumFields * SizeOf(PChar));
  254.     FreeMem(FieldNames, NumFields * SizeOf(PChar));
  255.     FieldTypes := nil;
  256.     FieldNames := nil;
  257.     Dispose(PCache(Cache), Done);
  258.     Cache := nil;
  259.     CurRecord := -1;
  260.   end;
  261. end;
  262.  
  263. function TPXTable.GetField(Rec, Fld: Integer): PChar;
  264. const
  265.   TheData: array[0..255] of Char = '';
  266. var
  267.   Tmp: array[0..255] of Char;
  268.   N: Double;
  269.   I: Integer;
  270.   L: LongInt;
  271.   ArgList: array[0..2] of Integer;
  272.   Index: LongInt;
  273.   P: PChar;
  274. begin
  275.   TheData[0] := #0;
  276.   GetField := TheData;
  277.   if Status <> 0 then Exit;
  278.   if Cache = nil then Exit;
  279.   if (Rec < 1) or (Rec > NumRecords) then Exit;
  280.   if (Fld < 1) or (Fld > NumFields) then Exit;
  281.   Index := Rec * NumFields + Fld;
  282.   P := PCache(Cache)^.Get(Index);
  283.   if P = nil then
  284.   begin
  285.     if Rec <> CurRecord then
  286.     begin
  287.       CheckError(PXRecGoto(TblHandle, Rec));
  288.       CheckError(PXRecBufEmpty(RecHandle));
  289.       CheckError(PXRecGet(TblHandle, RecHandle));
  290.       CurRecord := Rec;
  291.     end;
  292.     FillChar(TheData, SizeOf(TheData), ' ');
  293.     Tmp[0] := #0;
  294.     case FieldTypes^[Fld][0] of
  295.       'A':
  296.     CheckError(PXGetAlpha(RecHandle, Fld, SizeOf(Tmp), Tmp));
  297.       'N':
  298.     begin
  299.       CheckError(PXGetDoub(RecHandle, Fld, N));
  300.       if not IsBlankDouble(N) then
  301.         Str(N:12:4, Tmp);
  302.     end;
  303.       '$':
  304.     begin
  305.       CheckError(PXGetDoub(RecHandle, Fld, N));
  306.       if not IsBlankDouble(N) then
  307.         Str(N:12:2, Tmp);
  308.     end;
  309.       'S':
  310.     begin
  311.       CheckError(PXGetShort(RecHandle, Fld, I));
  312.       if not IsBlankShort(i) then
  313.         Str(I:6, Tmp)
  314.     end;
  315.       'D':
  316.     begin
  317.       CheckError(PXGetDate(RecHandle, Fld, L));
  318.       if Not IsBlankDate(L) then
  319.       begin
  320.         CheckError(PXDateDecode(L, ArgList[0], ArgList[1], ArgList[2]));
  321.         wvSprintf(Tmp, '%2d/%2d/%4d', ArgList);
  322.       end;
  323.     end;
  324.     end;
  325.     StrMove(TheData, Tmp, StrLen(Tmp));
  326.     TheData[FieldWidth(Fld)] := #0;
  327.     P := StrNew(TheData);
  328.     PCache(Cache)^.Add(Index, P);
  329.     GetField := P;
  330.   end
  331.   else
  332.     GetField := P;
  333. end;
  334.  
  335. function TPXTable.NumRecords: LongInt;
  336. begin
  337.   NumRecords := NumRecs;
  338. end;
  339.  
  340. function TPXTable.NumFields: Integer;
  341. begin
  342.   NumFields := NumFlds;
  343. end;
  344.  
  345. procedure TPXTable.PXError(Error: Integer);
  346. begin
  347.   MessageBox(GetFocus, PXErrMsg(Error), 'PXAccess', mb_OK)
  348. end;
  349.  
  350. function TPXTable.TblName: PChar;
  351. const
  352.   TableName: array[0..81] of Char = '';
  353. begin
  354.   if CheckError(PXTblName(TblHandle, SizeOf(TableName), TableName)) then
  355.     StrCat(TableName, '.DB');
  356.   TblName := @TableName;
  357. end;
  358.  
  359. function TPXTable.Update: Boolean;
  360. begin
  361.   if FileTime(TblName) = TableTime then Update:= False
  362.   else
  363.   begin
  364.     FlushTable;
  365.     CacheTable;
  366.     Update := True;
  367.   end;
  368. end;
  369.  
  370. end.
  371.